Developer CD Series 1992 June: ROMin Holiday

home *** CD-ROM | disk | FTP | other *** search

/ Developer CD Series 1992 June: ROMin Holiday / ADC Developer CD (1992-06) (''ROMin Holiday'')_iso / Developer Connection - 06-1992.iso / Development Platforms / LISP Related / Generalized LISP / Glisp 1.2 / Source files / Interpreter.glisp < prev next >

Wrap

Text File | 1990-08-19 | 58.9 KB | 2,015 lines | [TEXT/CCL ]

~---------------------------------------------------------------------------------------~ ~ Plisp interpreter ~ ~---------------------------------------------------------------------------------------~ -Mlisp- export( '( ~ functions peval papply pcall parse parseFile parseString parseList parseStream reparse defpfun addRules removeRules getRules sourceLanguage targetLanguage identifier aDelimiter aNumber aString aType reservedWord nonReservedWord eof isNot flush pVariable lhs rhs phs onLeft onRight pWarning pError checkFunction empty? peek next nextIs? nextAre? failure failed? failureValue? plispFunction? leftSide? rightSide? cat neql nequal nequalp plist pname printc str pTrace pFullTrace pTrap pUntrace pUnfullTrace pUntrap literal variable call repeat alternatives beginList endList lisp literals branches rewritesTo ), `:glisp); export( '( ~ variables `*lisp-readtable* `*glisp-readtable* `*glisp-sexp-readtable* `*pstandard-output* `*perror-output* `*ptrace-output* ), `:glisp); export( '( ~ symbols \! \@ \# \$ \% \^ \& \*  \_ \+ \- \= \{ \} \[ \] \: \" \; \' \< \> \? \, \. \/ \~ \` \| \\ \:\= \<\= \>\= \/\= \¡ \™ \£ \¢ \∞ \§ \¶ \• \ª \º \– \≠ \∑ \´ \® \† \¥ \¨ \^ \π \“ \‘ \∂ \ƒ \© \Δ \¬ \… \Ω \≈ \√ \∫ \µ \≤ \≥ \÷ \« \° \— \± \∏ \” \’ \ \◊ \¿ \» \œ \ø \å \æ \ç \ß \Œ \Ø \Å \Æ \Ç all done ), `:glisp); ~ these get bound by parse when parsing a Plisp file defvar( !reservedWords, nil, "(list) identifiers unquoted on left sides of rules"); defvar( !nRedefined, 0, "(integer) number of functions that were redefined"); ~ these get bound by papply when calling Plisp from Lisp defvar( !source, nil, "(headed list) the current input stream"); defvar( !savedSources, nil, "(stack) for backtracking; a stack because of flush"); defvar( !sourceStream, nil, "(stream/list) not-yet-scanned tail of input stream"); defvar( !sourceStack, nil, "(stack) for managing nested input"); defvar( !destStack, nil, "(stack) for managing nested output"); defvar( !sideStack, nil, "(stack) booleans saying which side of a rule we're on"); defvar( !sourceLanguage, nil, "(symbol) the language in which the input is written"); defvar( !targetLanguage, nil, "(symbol) the language defined by the input, if any"); defvar( !farthestIndex, 0, "(integer) index of farthest point reached in input"); defvar( !farthestTail, nil, "(list) remaining input at last advance of list input"); defvar( !farthestFailure, nil, "(string) failure message at farthest point in input"); defvar( !farthestFunction, nil, "(symbol) name of function containing !farthestFailure"); defvar( !varNames, nil, "(association list) for translating :variable names"); defvar( !pIndent, 0, "(integer) indentation level for trace output"); defvar( !currentPlispFunction, nil, "(symbol) name of current Plisp function--for tracing"); global `*readtable* ; ~(readtable) the current readtable in effect ~these get bound at beginning of every Plisp function defvar( !dest, nil, "(headed list) current output stream"); defvar( !variables, nil, "(association list) the current :variable bindings"); defvar( !inRepeat, nil, "(t, nil) are we inside a repeat [ ]* ?"); ~ these get bound at the beginning of every repeat (!inRepeat also gets rebound then) defvar( !repeatCount, 0, "(integer) number of times through the current repeat"); ~ miscellaneous globals defvar( !pTrace, nil, "(t, nil) are Plisp functions being traced?"); defvar( `*lisp-readtable*, nil, "(readtable) standard Common Lisp definition"); defvar( `*glisp-readtable*, nil, "(readtable) Glisp definition"); defvar( `*glisp-sexp-readtable*, nil, "(readtable) Glisp definition in s-expressions"); defvar( `*pstandard-output*, nil, "(stream) the standard Glisp output stream"); defvar( `*ptrace-output*, nil, "(stream) Glisp stream for tracing"); defvar( `*perror-output*, nil, "(stream) Glisp stream for errors"); ~ Common Lisp globals global `*trace-print-length* := 10, ~(integer) length of traced argument/value lists `*trace-print-level* := 5, ~(integer) depth of traced argument/value lists `*print-abbreviate-quote* ; ~(t, nil) turn (quote x) into 'x ? ~ Common Lisp stream index and end-of-stream indicator proclaim('`(object-variable ccl::index ccl::end)); defmacro failed? (ex) = ~ predicate: true iff the expression fails (i.e. calls failure()) when it is ~ executed. This allows one to call functions which may fail and still maintain ~ control when the failure happens. Example: ~ if failed?(w := foo(x, y, z)) then <something> else <something else> `(catch !failure ,ex nil) ; defsetf(vEval, vSet); ~ :x := y -> (setf (vEval n) y) -> (vSet n y) ~---------------------------------------------------------------------------------------~ ~ Plisp "op code" interpreter ~ ~---------------------------------------------------------------------------------------~ ~ ~ There are 9 basic operators that can occur in rules: ~ ~ literal (literal <atom>) ~ variable (variable <number> [t <pattern>]) ~ call (call <identifier> [<pattern>] [t]) ~ repeat (repeat <number> <number> <pattern> [<pattern>]) ~ alternatives (alternatives <number> <pattern> ... <pattern>) ~ beginList (beginList) ~ endList (endList) ~ lisp (lisp [if|do|value] <s-expression> ...) ~ rewritesTo (rewritesTo) ~ ~ plus 2 that result from the combination of rules: ~ ~ literals (literals (<atom> <item>...<item>) ... (<atom> <item>...<item>)) ~ branches (branches <pattern> ... <pattern>) ~ ~ These are implemented by "operation codes" that carry out the pattern matching. ~ All op codes are "predicates", where false is represented by calling failure(). ~ If any op code in a pattern fails, the whole pattern fails. ~ Most op codes (and therefore patterns) can fail on the left or right side of a rule. defun slVariable (var) = ~ single valued variable on left side of a rule: :x -> or .. -> ~ unbound :x fails only if there is no input ~ bound :x fails if the input doesn't match its value if vBound?(var) then ~ :x has a value begin new value := vEval(var, not !inRepeat); if !inRepeat and listp(value) then ~ [:x]* if !repeatCount > length(value) then ~ add to repeat list vSet(var, addValue(value, !repeatCount, next())) else nextIs?(value[!repeatCount]) or failure(":" cat var) else nextIs?(value) or failure(":" cat var); ~ :x end else if !inRepeat then ~ [:x]*, :x unbound if empty?() then failure(":" cat var) ~ no input left else vSet(var, {next()}) ~ first time through else if empty?() then failure(":" cat var) ~ no input left else vSet(var, next()); ~ :x unbound defun srVariable (var) = ~ single valued variable on right side of a rule: -> :x or -> .. ~ :x can fail only if it is in a repeat begin new value := if vBound?(var) then vEval(var, nil) ~ has a value else vSet(var, nil); ~ no value if !inRepeat and listp(value) then ~ [:x]* if !repeatCount > length(value) then ~ var exhausted failure(":" cat var) else !dest := !dest xCons value[!repeatCount] else !dest := !dest xCons value; ~ :x end; defun mlVariable (var, takeAllInput, firstTime) = ~ multiple valued variable on left side of a rule: ::x -> or ... -> ~ unbound ::x fails only if it runs out of input and its pattern still ~ hasn't matched ~ bound ::x fails if the input doesn't match its value or its pattern ~ doesn't match if vBound?(var) then ~ ::x has a value begin new value := vEval(var, firstTime and not !inRepeat); if not listp(value) then pError("the value of ::", var, " is not a list: ", value) else if !inRepeat then ~ [::x]* if !repeatCount > length(value) then ~ add a value vSet(var, addValue(value, !repeatCount, value[!repeatCount] nconc {next()})) else nextAre?(value[!repeatCount]) or failure("::" cat var) else if firstTime then nextAre?(value) or failure("::" cat var) else vset(var, value nconc {next()}); ~ add a value end else if !inRepeat then ~ unbound [::x]* if empty?() then failure("::" cat var) else vSet(var, {next()}) ~ first time through else if takeAllInput then ~ unbound ::x) or ::x -> if null !sourceStream then ~ optimization vSet(var, cdr !source) also !source := xNew() else pError("shouldn't happen") ~ *** ?? else vSet(var, {next()}); ~ unbound ::x defun mrVariable (var) = ~ multiple valued variable on right side of a rule: -> ::x or -> ... ~ ::x can fail only if it is in a repeat begin new value := if vBound?(var) then vEval(var, nil) ~ ::x has a value else vSet(var, nil); ~ ::x is unbound if not listp(value) then pError("the value of ::", var, " is not a list: ", value) else if !inRepeat then ~ [::x]* if !repeatCount > length(value) then ~ value exhausted failure("::" cat var) else !dest := !dest xAppend value[!repeatCount] else !dest := !dest xAppend value; ~ ::x end; defun lCall (fn, args, many) = ~ function call on left side of a rule: <fn> -> ~ can fail if any argument item fails or no rule matches begin new value, !currentPlispFunction := fn; value := if plispFunction?(fn) then ~ Plisp function !source := args xPrepend !source also apply(fn, nil) else ~ Lisp function {apply(fn, args)}; ~ add an extra set of parentheses if null value or car(value) eq !noValue then nil ~ function returned no value else if many then for v in reverse(value) do !source := v xPrepend !source else !source := value xPrepend !source; end; defun rCall (fn, args, many) = ~ function call on right side of a rule: -> <fn> ~ can fail if any argument item fails or no rule matches begin new value, !currentPlispFunction := fn; if plispFunction?(fn) then ~ Plisp function !source := args xPrepend !source also value := apply(fn, nil) else ~ Lisp function value := {apply(fn, args)}; ~ add an extra set of parentheses if null value or car(value) eq !noValue then nil ~ function returned no value else if many then for v in value do !dest := !dest xAppend v else !dest := !dest xAppend value; end; defun repeatMax (var) = ~ computes the maximum number of times to go through the repeat if vBound?(var) then vEval(var, nil) else nil; defun repeatStop? (max) = ~ predicate: true iff the number of repeat iterations exceeds the maximum ~ max = nil means there is no maximum begin !repeatCount := !repeatCount + 1; return max and !repeatCount > max; end; defun repeatSet (var, min) = ~ makes sure the repeat executed at least min times, then sets the repeat's ~ control variable to the number of iterations begin !repeatCount := !repeatCount - 1; ~ didn't complete the last iteration if not vBound?(var) then vSet(var, !repeatCount); ~ record the number of iterations if !repeatCount < min or !repeatCount < vEval(var, nil) then ~ didn't go through enough times failure(max(min, vEval(var, nil)) cat " iterations in a repeat [...]*"); end; defun altCheck (var) = ~ makes sure that an alternative control variable is bound if vBound?(var) then vEval(var, nil) else pError("unmatched alternatives on the right side of a rule"); defun lBeginList () = ~ beginning of list structure; starts a nested source list if listp(peek()) then pushSource(next()) else if nextIs?(!lParen) then pushSource(readSourceList()) else failure("("); defun rBeginList () = ~ beginning of list structure; starts a nested destination list ~ this could be expanded inline if we wish push(!dest, !destStack) also !dest := xNew(); defun lEndList () = ~ end of list structure; ends one level of nested source if empty?() and !sourceStack then popSource() else failure(")"); defun rEndList () = ~ end of list structure; ends one level of nested destination ~ this could be expanded inline if we wish !dest := xCons(pop(!destStack), cdr !dest); ~---------------------------------------------------------------------------------------~ ~ Other parsing functions ~ ~---------------------------------------------------------------------------------------~ defun beginPlispFunction (fn) = ~ entering a plisp function if !pTrace and (fn.pTrace or fn.pFullTrace) then begin !pIndent := !pIndent + 1; indentedPrintc("Calling <", fn, ">"); if fn.pFullTrace then begin new rules := getRules(fn); indentedPrintc("pattern: "); if null rules then princ(nil, `*ptrace-output*) else uncompilePattern(rules, `*trace-print-length*); end; indentedPrintc("input: "); princList(rest !source, `*ptrace-output*); terpri(`*ptrace-output*); if fn.pTrap then pbreak(); end; defun endPlispFunction (fn) = ~ exiting a plisp function begin if !pTrace and (fn.pTrace or fn.pFullTrace) then begin indentedPrintc("<", fn, "> -> "); princList(rest !dest, `*ptrace-output*); terpri(`*ptrace-output*); if fn.pTrap then pbreak(); !pIndent := !pIndent - 1; end; return cdr !dest; ~ value of the function end; defun setDecisionPoint () = ~ sets a decision point: 7 items are saved for backtracking begin push( !pIndent, !savedSources); push( cdr !source, !savedSources); push( !sourceStream, !savedSources); push( !sourceStack, !savedSources); push( cdr !dest, !savedSources); push( !destStack, !savedSources); push( !variables, !savedSources); end; defun restoreDecisionPoint () = ~ restores the state at the last decision point begin !pIndent := !savedSources[7]; !source := xHead(!savedSources[6]); !sourceStream := !savedSources[5]; !sourceStack := !savedSources[4]; !dest := xHead(!savedSources[3]); !destStack := !savedSources[2]; !variables := !savedSources[1]; return t; ~ value must be true end; defun deleteDecisionPoint () = ~ deletes the last decision point: 7 saved items begin !savedSources := nthcdr(7, !savedSources); return t; ~ value must be true end; ~---------------------------------------------------------------------------------------~ ~ Internal subroutines ~ ~---------------------------------------------------------------------------------------~ defun pushSource (newsource) = ~ manages nested input. ~ newsource must be a list. ~ after pushSource, !source is a list of all the input at the new level, ~ and !sourceStream is nil begin push(rest !source, !sourceStack); push(!sourceStream, !sourceStack); !source := xHead(newsource); !sourceStream := nil; end; defun popSource () = ~ manages nested input !sourceStream := pop(!sourceStack) also !source := xHead(pop(!sourceStack)); defun vBound? (var) = ~ predicate: true iff the plisp variable var has already been bound ~ analogous to boundp(var), but uses the !variables alist assoc(var, !variables); defun vEval (var, &optional traceit := t) = ~ gets the value of the plisp variable var ~ analogous to eval(var), but uses the !variables alist ~ all Plisp variables are effectively initialized to nil begin new x; if null x := assoc(var, !variables) then x := var cons nil; if !pTrace and !currentPlispFunction.pFullTrace and traceit then indentedPrintc(":", var, " = ", cdr x) also terpri(`*ptrace-output*); return cdr x; end; defun vSet (var, val, &optional traceit := t) = ~ sets the value of the plisp variable var to val ~ analogous to set(var, val), but uses the !variables alist begin !variables := (var cons val) cons remove(assoc(var, !variables), !variables); ~ don't use rplaca, so that variables can be backtracked if !pTrace and !currentPlispFunction.pFullTrace and traceit then indentedPrintc(":", var, " := ", val) also terpri(`*ptrace-output*); return val; end; defun addValue (l, i, value) = ~ returns the list 'l' with the 'i'th location replaced with 'value'. ~ does not use rplaca, so that 'l' can be backtracked. ~ 'l' will be extended with nils if its length is currently less than 'i'. ~ 'i' is assumed to be a positive integer. if i = 1 then value cons cdr(l) else car(l) cons addValue(cdr(l), i-1, value); defun canonicalName (var, onLeft, &aux x) = ~ maps symbolic names into numeric indicies to facilitate rule merging ~ e.g. :x :y :z -> 1 2 3 ~ handles generic items such as [] and ..., which are matched by position ~ var=nil is a wild card used to generate a new name if var member '(\. \[ \|) then if onLeft then ~ create a name for the item newName(var) else if x := assoc(var, !varNames) then ~ variable has already occurred car(x) := gensym() also ~ don't reuse it; cdr(x) ~ instead, bind by position else if var eq '\. then pWarning("too many ...'s on the right side of a rule") also newName(gensym()) else newName(gensym()) ~ []* only on right side are ok else if x := assoc(var, !varNames) then ~ variable has already occurred cdr(x) ~ use its existing name else if onLeft then ~ create a name for the variable newName(var) else pWarning("unbound variable on the right side of a rule: ", var) also newName(var); defun newName (var) = ~ creates a new canonical name (i.e. number) for a variable cdar(!varNames := (var cons length(!varNames) + 1) cons !varNames); defun restoreName (var, val) = ~ restores the name for a canonical value, e.g. <restoreName '[ :n> begin for pair in !varNames do nil until if cdr(pair) = val then car(pair) := var; return !noValue; end; defun recordMessage (message, override) = ~ records the error message for the farthest failure in the input stream if message and (null !farthestFailure or override) and not xNull?(!source) and (null cddr !source or !farthestTail eq rest !source) ~* (?) * and null !dest ~ implies on left side of rule then !farthestFailure := message also !farthestFunction := !currentPlispFunction; defun princAtom (name, &optional stream := `*pstandard-output*) = ~ princs an atom followed by a space princ(name, stream) also princ(" ", stream); defun princList (l, &optional stream := `*ptrace-output*) = ~ princs list elements separated by spaces for x in l do princAtom(x, stream); defun readSourceList () = ~ replaces '(' ... ')' in the input with a list; ~ note: this reads only LISTS, not DOTTED PAIRS, since I don't know how to tell ~ (a . b) from (a \. b)! ~ note: this is also unable to distinguish $ from ( and $ from ) in the input! let (`*readtable* := if `*readtable* eq `*glisp-readtable* then `*glisp-sexp-readtable* else `*readtable*) = if empty?() or nextIs?(!rParen) then nil ~ *** don't know how to make this work: *** ~ else if nextIs?('\.) then ~ prog1(next(), if not nextIs?(!rParen) then ~ error("illegal s-expression")) else next() cons readSourceList(); defun readSExpression (stream) = ~ reads a Plisp s-expression from a stream. ~ The structure of a Plisp s-expression is the same as in Lisp, but each atom ~ in it conforms to Plisp's syntax (i.e. what is a letter, etc.) let (`*readtable* := if `*readtable* eq `*glisp-readtable* then `*glisp-sexp-readtable* else `*readtable*) = `read-preserving-whitespace(stream, nil, !eof, nil); ~defun readAtom (stream) = ~ ~ reads a single atom from a stream. This is exactly like read, except when the ~ ~ next thing in the input is a left parenthesis. ~ ~ if `peek-char(nil, stream, nil, !eofchar, t) `char= `#\( then ~ `read-char(stream, nil, !eofchar, t) also ~ !lParen ~ else `read-preserving-whitespace(stream, nil, !eof, nil); defun lispRead (&optional stream, eofp, eofvalue, recursivep) = ~ reads an s-expression using the standard Lisp readtable. ~ this implements a principal interface to Lisp from Mlisp and Plisp let (`*readtable* := `*lisp-readtable*) = if consp(stream) then xpop(stream) else read(stream, eofp, eofvalue, recursivep); ~---------------------------------------------------------------------------------------~ ~ Defining rewrite functions ~ ~---------------------------------------------------------------------------------------~ defmacro defpfun (name, args, body, rules) = ~ defines a new Plisp function from scratch; analogous to defun and defmacro. ~ the rules should be already merged into a rule tree; ~ the body should be the expansion (into ordinary Lisp) of the rule tree `(&defpfun ',name ',args ',body ',rules); defun &defpfun (name, args, body, rules) = begin name.pRules := rules; ~ save the unexpanded rules name.pFunction := t; ~ mark it as a Plisp function eval {'defun, name, args, body}; ~ define the function end; defun addRules (name, rules, appearanceOrder) = ~ adds rules to an existing Plisp function. ~ gets the existing rules at EVAL time, not at TRANSLATE time begin eval papply('expandRules, {name, papply('mergeRules, {reverse(rules), getRules(name), appearanceOrder})}); return !noValue; end; defun removeRules (name, rules) = ~ removes rules from an existing Plisp function begin new tree := getRules(name); for rule in rules do tree := papply('removeRule, {lhsOnly(rule), tree}); eval papply('expandRules, {name, tree}); return !noValue; end; defun getRules (name) = ~ returns the rules for an existing Plisp function, or nil if it doesn't exist name.pRules; defun lhsOnly (rule) = ~ returns the left hand side of a rule if null rule then nil else if car(rule) equal '(rewritesTo) then {car(rule)} else car(rule) cons lhsOnly(cdr rule); defun linearMatch (l1, l2) = ~ tests for a simple rule match l1 equalp firstN(length(l1), l2); defun firstN (n, l) = ~ returns a list of the first n elements of a list if n < 1 or null l then nil else car(l) cons firstN(n-1, cdr l); defun makeReservedWord (word) = ~ makes 'word' be a reserved word in the current target language. ~ only adds words (identifiers) that occur on the left sides of rules begin if !targetLanguage and leftSide?() then !reservedWords := word adjoin !reservedWords; return word; end; defun reservedWords () = ~ returns a sorted list of the reserved words collected for a target language if !targetLanguage then {'declareReservedWords, {'quote, !targetLanguage}, {'quote, sort(!reservedWords, function(`string-lessp))}} else !noValue; defun declareReservedWords (language, words) = ~ makes each word in a list of words be a reserved word in a language begin for word in words do ~ mark each word with the language name word.(language) := t; language.reservedWords := words; ~ save the word list export(words); ~ export the words from current package export({language}); ~ export the language name too end; defun addReservedWords (language, words) = ~ adds reserved words to an existing language begin new l := language.reservedWords; for word in words do ~ mark each word with the language name word.(language) := t also l := word adjoin l; ~ add it to the word list language.reservedWords := sort(l, function(`string-lessp)); export(words); ~ export the words from current package end; defun sourceLanguage (language) = ~ switches source languages; asserts that the following input is in that language !sourceLanguage := language also !noValue; defun targetLanguage (language) = ~ switches target languages; all unquoted literal identifiers on the left sides ~ of rules will now be declared to be reserved words in that language !targetLanguage := language also !noValue; ~---------------------------------------------------------------------------------------~ ~ Headed list routines ~ ~---------------------------------------------------------------------------------------~ ~ ~ headed list (a b c) = ~ ~ [ • | •-]--> [ a | •-]--> [ b | •-]--> [ c | / ] ~ | | ~ --------------------------------->| ~ ~ empty headed list () = ~ ~ --> [ • | / ] ~ | | ~ |<----- defun xHead (l) = ~ converts the list l into a headed list if consp(l) then last(l) cons l else let (hl := l cons nil) = car(hl) := hl also hl; defun xNew () = ~ creates an empty headed list (an optimization for xHead(nil)) let (hl := nil cons nil) = car(hl) := hl also hl; defun xNull? (hl) = ~ predicate: true iff hl is the empty headed list null cdr(hl); defun xCons (hl, x) = ~ conses onto the end of a headed list cdar(hl) := x cons nil also car(hl) := cdar(hl) also hl; defun xAppend (hl, l) = ~ appends onto the end of a headed list if null l then hl else xAppend(hl xCons car(l), cdr(l)); defun xPrepend (l, hl) = ~ destructively appends a list onto the front of a headed list if null l then hl else progn(if xNull?(hl) then car(hl) := last(l) else cdr(last(l)) := cdr(hl), cdr(hl) := l, hl); defun xPop (hl) = ~ pops the first element of a headed list if null cddr(hl) then prog1(cadr(hl), cdr(hl) := cddr(hl), car(hl) := hl) else prog1(cadr(hl), cdr(hl) := cddr(hl)); ~---------------------------------------------------------------------------------------~ ~ Tracing routines ~ ~---------------------------------------------------------------------------------------~ defmacro pTrace (&rest pfunctions) = ~ traces an (unquoted) list of plisp functions ~ e.g. (pTrace foo bar zap ...) `(&pTrace ',pfunctions); defmacro pFullTrace (&rest pfunctions) = ~ "full traces" an (unquoted) list of plisp functions ~ full tracing generates more detailed output than tracing ~ e.g. (pFullTrace foo bar zap ...) `(&pFullTrace ',pfunctions); defmacro pTrap (&rest pfunctions) = ~ traps an (unquoted) list of plisp functions ~ trapping generates the same detailed output as full tracing, and in addition ~ breaks on every entry and exit from a trapped function ~ e.g. (pTrap foo bar zap ...) `(&pTrap ',pfunctions); defmacro pUntrace (&rest pfunctions) = ~ untraces an (unquoted) list of plisp functions ~ e.g. (pUntrace foo bar zap ...) `(&pUntrace ',pfunctions); defmacro pUnfullTrace (&rest pfunctions) = ~ untraces an (unquoted) list of plisp functions ~ e.g. (pUnfullTrace foo bar zap ...) `(&pUntrace ',pfunctions); defmacro pUntrap (&rest pfunctions) = ~ untraces an (unquoted) list of plisp functions ~ e.g. (pUntrap foo bar zap ...) `(&pUntrace ',pfunctions); defun &pTrace (pfunctions) = if null pfunctions then !pTrace := t also 'all.traceList else &pUntrace(pfunctions) also ~ first reset their previous state !pTrace := t also for pfn in pfunctions collect ~ then mark them to be traced {if plispFunction?(pfn) then pfn.pTrace := t also 'all.traceList := pfn cons 'all.traceList also pfn else nil}; defun &pFullTrace (pfunctions) = if null pfunctions then !pTrace := t also 'all.traceList else &pUntrace(pfunctions) also ~ first reset their previous state !pTrace := t also for pfn in pfunctions collect ~ then mark them to be fully traced {if plispFunction?(pfn) then pfn.pFullTrace := t also 'all.traceList := pfn cons 'all.traceList also pfn else nil}; defun &pTrap (pfunctions) = if null pfunctions then !pTrace := t also 'all.traceList else &pUntrace(pfunctions) also ~ first reset their previous state !pTrace := t also for pfn in pfunctions collect ~ then mark them to be trapped {if plispFunction?(pfn) then pfn.pFullTrace := t also pfn.pTrap := t also 'all.traceList := pfn cons 'all.traceList also pfn else nil}; defun &pUntrace (pfunctions) = ~ used for untracing and untrapping begin new value; if null pfunctions or pfunctions equal '(all) then pfunctions := reverse('all.traceList); value := for pfn in pfunctions collect {if pfn.pTrace or pfn.pFullTrace or pfn.pTrap then pfn.pTrace := pfn.pFullTrace := pfn.pTrap := nil also 'all.traceList := remove(pfn, 'all.traceList) also pfn else nil}; if null 'all.traceList then !pTrace := nil; return value; end; defun indentedPrintc (&rest args) = ~ a trace routine which prints its arguments indented on a new line begin new `*print-length* := `*trace-print-length*, `*print-level* := `*trace-print-level*; terpri(`*ptrace-output*); for i := 1 to !pIndent - 1 do princ(" ", `*ptrace-output*); princ("(", `*ptrace-output*); princ(!pIndent, `*ptrace-output*); princ(") ", `*ptrace-output*); for i:= 1 to `*print-length* for a in args do if stringp(a) then princ(a, `*ptrace-output*) else prin1(a, `*ptrace-output*); end; defun pBreak () = ~ breaks using Lisp's readtable, regardless of what the readtable was set to begin new `*readtable* := `*lisp-readtable* ; terpri(`*ptrace-output*); break(); terpri(`*ptrace-output*); end; ~---------------------------------------------------------------------------------------~ ~ The uncompiler ~ ~---------------------------------------------------------------------------------------~ defun uncompilePattern (pattern, n, &optional stream := `*ptrace-output*) = ~ turns the translated representation of a pattern back into its plisp form ~ only the first n items are uncompiled if null pattern then n else if n <= 0 then princ("...", stream) also 0 else uncompilePattern(rest pattern, uncompileItem(first pattern, n, stream), stream); defun uncompileItem (item, n, &optional stream := `*ptrace-output*) = ~ this does the work if atom item then princAtom(item, stream) also n-1 else case item[1] of begin literal: ~ (literal <atom>) princAtom(item[2], stream) also n-1; variable: ~ (variable <number> [t <pattern>] ) begin princ(if item[3] then "::" else ":", stream); princAtom(item[2], stream); return if item[4] then uncompilePattern(item[4], n-1, stream) else n-1; end; call: ~ (call <identifier> [<pattern> [t]]) begin princ(if item[4] then "<<" else "<", stream); princ(item[2], stream); if item[3] then princ(" ", stream) also n := uncompilePattern(item[3], n-1, stream); princ(if item[4] then ">> " else "> ", stream); return n; end; alternatives: ~ (alternatives var <pattern> ... <pattern>) begin new patterns := cddr(item); princ("[ ", stream); n := uncompilePattern(first patterns, n, stream); if length(patterns) > 2 or second patterns then for pattern in rest patterns do princ("| ", stream) also n := uncompilePattern(pattern, n, stream); princ("] ", stream); return n; end; repeat: ~ (repeat var min <pattern> [<pattern>]) begin princ("[ ", stream); n := uncompilePattern(item[4], n, stream); if item[5] then princ("/ ", stream) also n := uncompilePattern(item[5], n, stream); princ(if item[3] = 0 then "]* " else "]+ ", stream); return n; end; beginList: ~ (beginList) princ("( ", stream) also n-1; endList: ~ (endList) princ(") ", stream) also n-1; lisp: ~ (lisp [if|do|value] <s-expression> ...) begin princ(if item[2] eq 'value and item[4] then "{{" else "{", stream); princAtom(item[2], stream); prin1(item[3], stream); princ(if item[2] eq 'value and item[4] then "}} " else "} ", stream); return n-2; end; `(literals branches): ~ (literals (<atom> <item>...) ... (<atom> <item>...)) ~ (branches <pattern> ... <pattern>) begin princ("{", stream); princAtom(item[1], stream); uncompilePattern(item[2], 1, stream); for pattern in cddr(item) do princ(", ", stream) also uncompilePattern(pattern, 1, stream); princ("} ", stream); return 0; end; rewritesTo: ~ (rewritesTo) princ("-> ", stream) also n-1; t: ~ shouldn't happen princAtom(item, stream) also n-1; end; defun humanize (item) = ~ similar to uncompile, except that it attempts to make translated pattern items ~ even more human readable `string-downcase(humanize1(item)); defun humanize1 (item) = ~ this does the work if null item then "something" else if atom item then str(item) else case item[1] of begin literal: ~ (literal <atom>) "'" cat item[2] cat "'"; variable: ~ (variable <number> [t <pattern>] ) (if item[3] then "::" else ":") cat item[2]; call: ~ (call <identifier> [<pattern> [t]] ) "<" cat item[2] cat ">"; alternatives: ~ (alternatives var <pattern> ... <pattern>) begin new s, patterns := cddr(item); s := humanize1(first first patterns); for pattern in rest patterns do s := s cat " or " cat humanize1(first pattern); return s; end; repeat: ~ (repeat var min <pattern> [<pattern>]) "something"; beginList: ~ (beginList) "'('"; endList: ~ (endList) "')'"; lisp: ~ (lisp [if|do|value] <s-expression> ...) case item[2] of begin if: "'" cat item[3] cat "' to be true"; do: "'" cat item[3] cat "' to not fail"; value: "the value of '" cat item[3] cat "'"; t: pWarning("unknown item in a pattern: " cat item) also ""; end; literals: ~ (literals (<atom> <item>...) ... (<atom> <item>...)) begin new s := humanize1({'literal, first item[2]}); for pattern in cddr(item) do s := s cat " or " cat humanize1({'literal, first pattern}); return s; end; branches: ~ (branches <pattern> ... <pattern>) begin new s := humanize1(first item[2]); for pattern in cddr(item) do s := s cat " or " cat humanize1(first pattern); return s; end; rewritesTo: ~ (rewritesTo) "nothing"; t: pWarning("unknown item in a pattern: " cat item) also ""; end; defun ruleToString (rule) = ~ "uncompiles" a rule, turning it into a string `with-output-to-string(`(out), patternToString(rule, out)); defun patternToString (pattern, out) = ~ handles embedded patterns if pattern then itemToString(first pattern, out) also for item in rest(pattern) do princ(" ", out) also itemToString(item, out); defun itemToString (item, out) = ~ similar to uncompile, except that it puts translated pattern items in a string if null item then nil else if atom item then princ(item, out) else case item[1] of begin literal: ~ (literal <atom>) princ(item[2], out); variable: ~ (variable <number> [t <pattern>]) begin princ(if item[3] then "::" else ":", out); princ(item[2], out); if item[4] then princ(" ", out) also patternToString(item[4], out); end; call: ~ (call <identifier> [<pattern> [t]]) begin princ(if item[4] then "<<" else "<", out); princ(item[2], out); if item[3] then princ(" ", out) also patternToString(item[3], out); princ(if item[4] then ">>" else ">", out); end; alternatives: ~ (alternatives var <pattern> ... <pattern>) begin new patterns := cddr(item); princ("[", out); if null patterns then nil else if length(patterns) = 2 and null patterns[2] then patternToString(first patterns, out) ~ optional [pat] else patternToString(first patterns, out) also for pattern in rest(patterns) do princ(" | ", out) also patternToString(pattern, out); princ("]", out); end; repeat: ~ (repeat var min <pattern> [<pattern>]) begin princ("[", out); patternToString(item[4], out); if item[5] then princ(" / ", out) also patternToString(item[5], out); princ(if item[3] = 0 then "]*" else "]+", out); end; beginList: ~ (beginList) princ("(", out); endList: ~ (endList) princ(")", out); lisp: ~ (lisp [if|do|value] <s-expression> ...) case item[2] of begin if: princ("{if " cat item[3] cat "}", out); do: princ("{do " cat item[3] cat "}", out); value: princ( if item[4] then "{{value " cat item[3] cat "}}" else "{value " cat item[3] cat "}", out); t: pWarning("unknown item in a pattern: " cat item) also ""; end; `(literals branches): ~ (literals (<atom> <item>...) ... (<atom> <item>...)) ~ (branches <pattern> ... <pattern>) begin princ("{", out); patternToString(item[2], out); for pattern in cddr(item) do princ(", ", out) also patternToString(pattern, out); princ("} ", out); return 0; end; rewritesTo: ~ (rewritesTo) princ("->", out); t: pWarning("unknown item in a pattern: " cat item); end; ~---------------------------------------------------------------------------------------~ ~ Type checkers -- callable from Plisp rules ~ ~---------------------------------------------------------------------------------------~ defun identifier () = ~ Checks if the next thing in the input is an identifier; returns it if so. ~ An identifier is any symbol which is not a delimiter. Conceptually an ~ identifier is like a word in English, i.e. made up of letters and digits. ~ The letters are the alphabet a...z, the international characters ~ æ Æ œ Œ ø Ø å Å ç Ç ß, the special characters ! ? _ & and any character ~ preceded by a back slash (\). ~ 'identifier' is a PLISP CONCEPT, not a Lisp data type. let (atm := peek()) = if symbolp(atm) and not atm.delimiter then next() else failure("an identifier"); defun aDelimiter () = ~ Checks if the next thing in the input is a delimiter; returns it if so. ~ A delimiter is any symbol which is marked with the property 'glisp::delimiter'. ~ Conceptually a delimiter is any character which is not a letter, digit or ~ white space character, e.g. @ # $ % ^ & + - * / = [ ] ( ) { } < > etc. ~ 'delimiter' is a PLISP CONCEPT, not a Lisp data type. let (atm := peek()) = if symbolp(atm) and atm.delimiter then next() else failure("a delimiter"); defun aNumber () = ~ tests if the next thing in the input is a Lisp number; returns it if so. ~ this is faster than calling <aType number> if numberp(peek()) then next() else failure("a number"); defun aString () = ~ tests if the next thing in the input is a Lisp string; returns it if so. ~ this is faster than calling <aType string> if stringp(peek()) then next() else failure("a string"); defun aType (typ) = ~ general type checker: tests if the next thing in the input is of Lisp type ~ 'typ'; returns it if so. ~ (hint) in general, specific type checking functions such as aNumber and aString ~ should be written whenever a type of item is checked for frequently; passing ~ arguments in Plisp function calls, e.g. <aType string>, is fairly inefficient. if typep(peek(), typ) then next() else failure("an item of type '" cat typ cat "'"); defun reservedWord () = ~ this is the same as 'identifier' except that it fails if the identifier is not ~ a reserved word in the current source language. ~ reserved words are identified by having the name of the language as a property, ~ e.g. begin --> (mlisp t ...) let (atm := peek()) = if symbolp(atm) and atm.(!sourceLanguage) then next() else failure("a reserved word"); defun nonReservedWord () = ~ this is the same as 'reservedWord' except that it fails if the identifier IS ~ a reserved word in the current source language. let (atm := peek()) = if symbolp(atm) ~ a symbol and not atm.delimiter ~ and not a delimiter and not atm.(!sourceLanguage) ~ and not a reserved word in the then next() ~ current source language else failure("a non reserved-word identifier"); defun eof () = ~ checks if the input is exhausted; fails if it isn't if peek() eq !eof then !noValue else failure(!eof); defun isNot (x) = ~ succeeds iff the next thing in the input is NOT x; fails if it is. ~ x may be any s-expression. if peek() equalp x then failure("to not find '" cat x cat "'") else !noValue; ~---------------------------------------------------------------------------------------~ ~ Utility functions callable from Plisp rules ~ ~---------------------------------------------------------------------------------------~ defun flush () = ~ deletes all the saved backtracking state, in order to reclaim space. ~ everything in a pattern after <flush> MUST SUCCEED, otherwise the results ~ are unpredictable; see Plisp.glisp and Mlisp.glisp for examples. !savedSources := nil also ~ clear out the saved source lists !noValue; ~ <flush> returns no value defun pVariable (&optional var := identifier(), onLeft := leftSide?()) = ~ returns the canonical name for a Plisp variable. ~ if a variable is not supplied, it will read one from the input stream. canonicalName(var, onLeft); defun lhs () = ~ "left hand side" ~ asserts that we're on the left hand side of a rule at PARSE time begin !varNames := nil; push(nil, !sideStack); ~ (nil ...) => left hand side return !noValue; end; defun rhs () = ~ "right hand side" ~ asserts that we're on the right hand side of a rule at PARSE time begin if leftSide?() then ~ going from left to right side !varNames := reverse(!varNames); push(t, !sideStack); ~ (t ...) => right hand side return !noValue; end; defun phs () = ~ "previous hand side" ~ returns to the previous side of the rule we were on before the last change. ~ this is always paired with a call to <rhs> begin pop(!sideStack); ~ restore the previous value if leftSide?() then ~ going from right to left side !varNames := reverse(!varNames); ~ restore the previous order return !noValue; end; defun onLeft () = ~ fails unless it occurs on the left side of a rule at PARSE time if leftSide?() then !noValue else failure(); ~ don't supply an argument here defun onRight () = ~ fails unless it occurs on the right side of a rule at PARSE time if rightSide?() then !noValue else failure(); ~ don't supply an argument here defun pWarning (&rest messages) = ~ prints a warning message on the standard output stream (the display usually). ~ any number of s-expressions may be passed to 'pWarning'. begin `fresh-line(`*pstandard-output*); ~ start a new line if necessary princ("*** Warning, ", `*pstandard-output*); for m in messages do princ(m, `*pstandard-output*); terpri(`*pstandard-output*); return !noValue; ~ has no Plisp value end; defun pError (&rest messages) = ~ error during pattern matching. ~ prints an error message on the display and breaks using the Lisp readtable. ~ any number of s-expressions may be passed to 'pError'. begin new `*readtable* := `*lisp-readtable*; terpri(`*perror-output*); printc("*** Error,", `*perror-output*); for m in messages do princ(m, `*perror-output*); printc("*** Input:"); princList(rest !source, `*perror-output*); terpri(`*perror-output*); terpri(`*perror-output*); break(); ~ break to Lisp !source := xNew(); ~ when we return, clear out the input failure(); ~ and fail end; defun checkFunction (fn) = ~ prints a function name on the standard output stream (the display usually). ~ also checks if the function already has a definition begin if symbolp(fn) and fboundp(fn) then pWarning("function redefined: ", fn) also !nRedefined := !nRedefined + 1 else princAtom(fn, `*pstandard-output*); return !noValue; end; ~---------------------------------------------------------------------------------------~ ~ Other routines available to Plisp programmers ~ ~---------------------------------------------------------------------------------------~ ~ ~ when input is coming from a stream: ~ !source = a headed list that always has at least one element (which is !eof ~ at end of file) ~ !sourceStream = the stream from which tokens are read to replenish !source. ~ when input is coming from a list: ~ !source = a headed list that can be xnull ~ !sourceStream = nil defun empty? () = ~ predicate: true iff the input stream is empty xNull?(!source) or cadr(!source) eq !eof; defun peek () = ~ returns the next token in the input stream. ~ this is non-destructive; the input stream is not changed. ~ this and 'next' are the two basic functions for obtaining tokens from the ~ input stream. if empty?() then !eof else cadr(!source); defun next () = ~ removes the next token from the input stream and returns it. ~ this and 'peek' are the two basic functions for obtaining tokens from the ~ input stream. if null !sourceStream then ~ processing a list if empty?() then failure() ~ *** should this be !eof ?? else if !farthestTail eq cdr(!source) then prog1(xPop(!source), !farthestTail := cdr !source) else xPop(!source) else if cddr(!source) then ~ reprocessing already-scanned input xPop(!source) else begin ~ processing a stream ~ must leave at least one element, so read one from the stream new x; !farthestFailure := nil; !farthestFunction := nil; !farthestIndex := ask(!sourceStream, currIndex()); x := `read-preserving-whitespace(!sourceStream, nil, !eof, nil); !source := !source xCons x; ~ *** kludge: always reads an s-expression after a quote mark (') *** if x eq '\' then !source := !source xCons readSExpression(!sourceStream); return xPop(!source); end; defun nextIs? (x) = ~ predicate: true iff the next item in the input stream is equalp to x; ~ removes it if so. x may be any s-expression. if peek() equalp x then next() also t else nil; defun nextAre? (l) = ~ predicate: true iff the next sequence of tokens in the input stream are all ~ equalp to the s-expressions in the list 'l'; removes them if so. every(function(lambda (x) = nextIs?(x)), l); defun failure (&optional message, override) = ~ an item in a pattern has failed to match the input. ~ execute a throw to the tag bound to the constant !failure. ~ every decision point in a pattern sets up a catch for this throw. ~ the item associated with the furthest point reached in the input is remembered ~ for later printing in an error message if necessary. ~ the message passed in should be a string or other value which is suitable for ~ appending to the string ~ "<function> expected " ~ e.g. if you want the error message to read ~ "<expression> expected a 'foo', but it got a 'bar' instead" ~ the argument to failure should be ~ "a 'foo', but it got a 'bar' instead" begin if !pTrace and !currentPlispFunction.pFullTrace and message then begin indentedPrintc("item failed: ", message); indentedPrintc("input: "); princList(rest !source, `*ptrace-output*); terpri(`*ptrace-output*); if !currentPlispFunction.pTrap then pbreak(); end; recordMessage(message, override); throw(!failure, t); end; defun failureValue? (value) = ~ does the value returned by papply represent a failure? consp(value) and first(value) eq !failure; defun plispFunction? (fn) = ~ predicate: true iff 'fn' is the name of a plisp (i.e. rewrite) function symbolp(fn) and fn.pFunction; defun leftSide? () = ~ predicate: true iff this is called from an item on the left side of a rule ~ at PARSE time not car(!sideStack); defun rightSide? () = ~ predicate: true iff this is called from an item on the right side of a rule ~ at PARSE time car(!sideStack); ~---------------------------------------------------------------------------------------~ ~ Utility functions of general interest to Lisp programs ~ ~---------------------------------------------------------------------------------------~ defun cat (x, y) = ~ concatenates any two objects into a string concatenate('string, str(x), str(y)); defun neql (x, y) = ~ for completeness and symmetry with 'eql' not(x eql y); defun nequal (x, y) = ~ for completeness and symmetry with 'equal' not(x equal y); defun nequalp (x, y) = ~ for completeness and symmetry with 'equalp' not(x equalp y); defun plist (x) = ~ for historical compatibility `symbol-plist(x); defun pname (x) = ~ for historical compatibility `symbol-name(x); defun printc (x, &optional stream := nil) = ~ analogous to 'print', but uses 'princ' instead of 'prin1' terpri(stream) also princ(x, stream) also princ(" ", stream) also x; defun str (x) = ~ converts anything to a string if stringp(x) then x else if symbolp(x) then `symbol-name(x) else `princ-to-string(x); ~---------------------------------------------------------------------------------------~ ~ Interface Lisp -> Plisp ~ ~---------------------------------------------------------------------------------------~ defun peval (l, &key source := 'glisp, target := nil, readtable := `*glisp-readtable*) = ~ Lisp -> Plisp interface. ~ :source is the language in which the input is written. ~ :target is the language being defined by the input, if any. ~ :readtable is the readtable to use in scanning tokens. ~ example: peval('(expression if a = b then c else d), :source 'mlisp) if consp(l) then papply(first l, rest l, :source source, :target target, :readtable readtable) else error("the argument to 'peval' must be a list: \~a", l); defun papply (pfn, args, &key :source !sourceLanguage := 'glisp, :target !targetLanguage := nil, :readtable `*readtable* := `*glisp-readtable*) = ~ Lisp -> Plisp interface ~ :source is the language in which the input is written. ~ :target is the language being defined by the input, if any. ~ :readtable is the readtable to use in scanning tokens. ~ example: papply('glisp::expression, '(if a = b then c else d \;), ~ :source 'mlisp) begin ~ set up the Plisp execution context new !source, !sourceStream, !farthestTail, ~ these are bound below !savedSources := nil, !sourceStack := nil, !destStack := nil, !sideStack := nil, !varNames := nil, !farthestFailure := nil, !farthestFunction := pfn, !farthestIndex := 0, !currentPlispFunction := pfn, !pIndent := 0; new value; ~ check the arguments if not plispFunction?(pfn) then return error( "the first argument to 'papply' must be the name of a Plisp function: \~a", pfn); ~ see where the input is coming from typecase args of begin list: !sourceStream := nil also !source := xHead(args) also !farthestTail := rest !source; stream: !sourceStream := args also !source := xHead({`read-preserving-whitespace( !sourceStream, nil, !eof, nil)}) also !farthestTail := nil; otherwise: return error("the second argument to 'papply' must be a list " cat " or a stream, not a \~a", `type-of(args)); end; ~ execute the plisp function, picking up the input stream free return if failed?(value := apply(pfn, nil)) then ~ catch failures {!failure, !source, "<" cat ( if !farthestFunction then `string-downcase(!farthestFunction) else "an unknown function") cat "> expected " cat (!farthestFailure or "something"), if listp(args) then !farthestTail else !farthestIndex} else if atom(value) or rest(value) then ~ no values or multiple values value else first(value); ~ a single value end; defun pcall (pfn, args) = ~ calls a Plisp function from Lisp when the Plisp execution environment is ~ already set up; i.e. the Lisp function was itself called from a Plisp function begin new value; if args then ~ are arguments being passed? !source := `copy-list(args) xPrepend !source; value := apply(pfn, nil); return if consp(value) then car(value) else value; end; ~---------------------------------------------------------------------------------------~ ~ Stream parsing functions ~ ~---------------------------------------------------------------------------------------~ defun parse ( ~ the main Glisp parsing driver ifile, ~ the input file name &key :output ofile := nil, ~ the output file name, if any pretty := nil, ~ pretty print the output? evaluate := t, ~ evaluate the translation? asString := nil, ~ interpret ifile as a source string? source := 'glisp, ~ language in which the input is written target := nil, ~ language being defined by the input parser := 'glispProgram, ~ main Glisp parsing function readtable := `*glisp-readtable*, ~ the readtable to use in scanning package := nil) = ~ if this is part of a package begin new tim, value, !reservedWords := nil, !nRedefined := 0, `*package* := if package then `find-package(package) or return error("no such package: " cat package) else `*package* ; if stringp(ifile) and not asString then announce(ifile, ofile); printc("----------", `*pstandard-output*); terpri(`*pstandard-output*); tim := `get-internal-run-time(); value := if null ifile then parseString(`read-line(t, nil, !eof, nil), parser, :source source, :target target, :readtable readtable) else if asString and stringp(ifile) then parseString(ifile, parser, :source source, :target target, :readtable readtable) else if stringp(ifile) then parseFile(ifile, parser, :source source, :target target, :readtable readtable) else if listp(ifile) then parseList(ifile, parser, :source source, :target target, :readtable readtable) else if streamp(ifile) then parseStream(ifile, parser, :source source, :target target, :readtable readtable) else return error("the first argument to 'parse' must be a string, " cat "list, or stream, not a \~a: \~a", `type-of(ifile), ifile); tim := (`get-internal-run-time() - tim) / `internal-time-units-per-second; `fresh-line(`*pstandard-output*); princ("----------", `*pstandard-output*); if value eq !failure then return !failure; printc(round(float(tim)) cat " seconds translation time", `*pstandard-output*); printc(!nRedefined cat " functions redefined", `*pstandard-output*); if ofile then printTranslation(value, ofile, pretty) else if evaluate then begin terpri(`*pstandard-output*); printc("Evaluating the translation...", `*pstandard-output*); for x in value do eval(x); end; terpri(`*pstandard-output*); terpri(`*pstandard-output*); return if not evaluate then value ~ just return the translation else if package then `*package* else 'done; end; defun parseFile (filename, parser, &key source := 'glisp, target := nil, readtable := `*glisp-readtable*) = ~ parses a file written in the source language ~ e.g. parseFile("mlisp.glisp", 'glispProgram, :source 'glisp, :target 'mlisp) begin new value; `with-open-file( `(stream (merge-pathnames filename) :direction :input :element-type 'character :if-does-not-exist :error), value := papply(parser, stream, :source source, :target target, :readtable readtable), if failureValue?(value) then explainError(value, stream) also value := !failure); return value; end; defun parseString (s, parser, &key source := 'glisp, target := nil, readtable := `*glisp-readtable*) = ~ parses a string written in the source language ~ e.g. parseString("a -> b", 'rule) begin new value; `with-input-from-string( `(stream s), value := papply(parser, stream, :source source, :target target, :readtable readtable), if failureValue?(value) then explainError(value, s, ask(stream, `ccl::end)) also value := !failure); return value; end; defun parseList (l, parser, &key source := 'glisp, target := nil, readtable := `*glisp-readtable*) = ~ parses a list written in the source language ~ e.g. parseList('(a - > b), 'rule) begin new value; value := papply(parser, l, :source source, :target target, :readtable readtable); if failureValue?(value) then explainError(value, l) also value := !failure; return value; end; defun parseStream (s, parser, &key source := 'glisp, target := nil, readtable := `*glisp-readtable*) = ~ parses a stream written in the source language; this is the same as parseList ~ e.g. parseStream(s, 'rule) parseList(s, parser, :source source, :target target, :readtable readtable); defun reparse (name, filename, &key source := 'glisp, target := nil, parser := 'reparsePlispFunction, locater := 'locatePlispFunction, readtable := `*glisp-readtable*, package := nil) = ~ translates a single Plisp function in a file. ~ this is useful during debugging to keep from having to reparse an entire file ~ every time you make a change. ~ the definition of what is to be translated is provided by the "parser" Plisp ~ function, which defaults to 'reparsePlispFunction'. ~ :source is the language in which the input is to be interpreted. ~ :target is the language, if any, being defined by the input. ~ the user may supply a "locater" function to skip to where the item begins; ~ such a function must take two arguments: the name of the item (a symbol) ~ and the stream to search, and return true iff it successfully finds it. ~ e.g. reparse('foo, "mlisp.gli", :source 'mlisp, :parser 'mlispFunction, ~ :locater 'locateMlispFunction, :package `:glisp) begin new value, !reservedWords := nil, !nRedefined := 0, `*package* := if package then `find-package(package) or return error("no such package: " cat package) else `*package* ; if package then name := intern(pname(name)); ~ translate to that package's symbol `with-open-file( `(stream (merge-pathnames filename) :direction :input :element-type 'character :if-does-not-exist :error), ~ skip to where the item begins if apply(locater, {name, stream, readtable}) then begin value := papply(parser, stream, :source source, :target target, :readtable readtable); if failureValue?(value) then explainError(value, stream) else begin if target then addReservedWords(target, !reservedWords); eval(value); end; end else printc("Item not found: " cat name, `*pstandard-output*)); return `*package*; end; defun locatePlispFunction (name, stream, `*readtable*) = ~ quickly skips to the beginning of a Plisp function; works only on file streams begin new x := '\;, index, foundit; until (x eq '\; or x eq '\- or x eq !eof) and case x of begin \; : ~ ; name = ... begin index := `file-position(stream); foundit := read(stream, nil, !eof, nil) eq name and read(stream, nil, !eof, nil) member '(\= \(); `file-position(stream, index); return foundit; end; \- : ~ -Plisp- name = ... begin index := `file-position(stream); foundit := read(stream, nil, !eof, nil) eq 'Plisp and read(stream, nil, !eof, nil) eq '\- and (index := `file-position(stream)) and read(stream, nil, !eof, nil) eq name and read(stream, nil, !eof, nil) member '(\= \(); `file-position(stream, index); return foundit; end; otherwise: ~ end of file t; end do x := read(stream, nil, !eof, nil); return x neq !eof; end; defun printTranslation (l, filename, pretty) = ~ prints or pretty prints all of the elements in the list 'l' to a file begin new `*print-abbreviate-quote* := nil; ~ don't turn (quote x) into 'x terpri(`*pstandard-output*); filename := `merge-pathnames(filename); printc(if pretty then "Pretty printing" else "Printing", `*pstandard-output*); princ("the translation on " cat namestring(filename) cat "...", `*pstandard-output*); `with-open-file( `(stream filename :direction :output :element-type 'character :if-exists :supersede :if-does-not-exist :create), for x in l do begin if pretty then pprint(x, stream) else print(x, stream); terpri(stream); end); end; defun explainError (value, stream, &optional endPos := nil) = ~ explains the meaning of an error returned by 'papply' ~ value = (!failure !source errorMessage !farthestIndex/Tail) let (!source := value[2], !sourceStream, !sourceStack, !currentPlispFunction) = failed?(pError(value[3], ": ", if listp(value[4]) then if value[4] then first value[4] else "end of the input" else if endPos then subseq(stream, value[4], endPos) else if consp(stream) then "" else `file-position(stream, value[4]) also `read-line(stream, nil, !eof, nil))); defun announce (ifile, ofile) = ~ prints on the screen the name of the file that's about to be translated begin terpri(`*pstandard-output*); princ(`pathname-name(ifile), `*pstandard-output*); ~ don't use printc here if `pathname-type(ifile) then princ("." cat `pathname-type(ifile), `*pstandard-output*); if ofile then princ(" -> " cat `pathname-name(ofile), `*pstandard-output*) also if `pathname-type(ofile) then princ("." cat `pathname-type(ofile), `*pstandard-output*); princ("...", `*pstandard-output*); end; defobfun currIndex (`*stream*) () = `ccl::index; defobfun currIndex (`ccl::*file-stream*) () = `file-position(self());